home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / graphics / mm_tease.zip / SOURCE.LZH / TEASER.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-17  |  22KB  |  860 lines
  1. program Skull;
  2.  
  3. uses
  4.   vga4page, crt;
  5.  
  6. {$M $4000,0,0}             {16k stack, no heap - adjust as needed }
  7. {$L MOD-obj.OBJ}             { Link in Object file }
  8.  
  9. type
  10.   PointRec3D = array [1..3] of
  11.     record
  12.       x, y, z : integer
  13.     end;
  14.  
  15.   Triangles = array [1..17] of PointRec3D;
  16.  
  17. var
  18.   t, t2 : triangles;
  19.   velocity : array [1..17] of
  20.     record
  21.       x, y, dx, dy,
  22.       theta1, theta2, theta3,
  23.       dt1, dt2, dt3 : integer;
  24.     end;
  25.   eye1x, eye1y, eye2x, eye2y : integer;
  26.   nose1x, nose1y, nose2x, nose2y, nose3x, nose3y,
  27.   nose4x, nose4y, nose5x, nose5y, nose6x, nose6y : integer;
  28.   dev : integer;  { sound device for mod }
  29.   font : array [0..255, 0..15] of byte;
  30.   page  : integer;
  31.  
  32. {$F+}                 { force calls to be 'far'}
  33. procedure modvolume(v1,v2,v3,v4:integer); external ; {Can do while playing}
  34. procedure moddevice(var device:integer); external ;
  35. procedure modsetup(var status:integer;device,mixspeed,pro,loop:integer;var str:string); external ;
  36. procedure modstop; external ;
  37. procedure modinit; external;
  38. {$F-}
  39.  
  40. procedure RGB (color, red, green, blue : integer);
  41.  
  42.   begin
  43.     while (port [$3da] and 8) <> 8 do;
  44.     port [$3c8] := color;
  45.     port [$3c9] := red;
  46.     port [$3c9] := green;
  47.     port [$3c9] := blue
  48.   end;
  49.  
  50. Function ISqrt(a:word):integer;
  51. begin
  52.   Isqrt:=round(sqrt(a));
  53. end;
  54.  
  55. procedure fillcircle (x_center, y_center, radius, color : integer);
  56.  
  57.   var
  58.     x,y,r2:integer;
  59.  
  60.   begin
  61.     if radius=0 then exit;
  62.     r2:=radius*radius;
  63.     x:=0;
  64.     y:=radius;
  65.     repeat
  66.       hline(x_center-x,x_center+x,y_center-y,color,page);
  67.       hline(x_center-x,x_center+x,y_center+y,color,page);
  68.       hline(x_center-y,x_center+y,y_center-x,color,page);
  69.       hline(x_center-y,x_center+y,y_center+x,color,page);
  70.       inc(x);
  71.       y:=isqrt(r2-x*x);
  72.     until x>y;
  73.   end;
  74.  
  75. Procedure DrawQuad(x1,y1,x2,y2,x3,y3,x4,y4:word;color:byte);
  76.  
  77. var
  78.   i,x:integer;
  79.   mny,mxy:integer;
  80.   mnx,mxx,yc:integer;
  81.   mul1,div1,mul2,div2,mul3,div3,mul4,div4:integer;
  82.  
  83. begin
  84.   mny:=y1; mxy:=y1;
  85.   if y2<mny then mny:=y2;
  86.   if y2>mxy then mxy:=y2;
  87.   if y3<mny then mny:=y3;
  88.   if y3>mxy then mxy:=y3;
  89.   if y4<mny then mny:=y4;
  90.   if y4>mxy then mxy:=y4;
  91.   if mny<0 then mny:=0;
  92.   if mxy>479 then mxy:=479;
  93.   mul1:=x1-x4; div1:=y1-y4;
  94.   mul2:=x2-x1; div2:=y2-y1;
  95.   mul3:=x3-x2; div3:=y3-y2;
  96.   mul4:=x4-x3; div4:=y4-y3;
  97.   for yc:=mny to mxy do
  98.     begin
  99.       mnx:=360;
  100.       mxx:=-1;
  101.       if (y4>=yc) or (y1>=yc) then
  102.         if (y4<=yc) or (y1<=yc) then
  103.           if not(y4=y1) then
  104.             begin
  105.               x:=(yc-y4)*mul1 div div1+x4;
  106.               if x<mnx then
  107.                 mnx:=x;
  108.               if x>mxx then
  109.                 mxx:=x;
  110.             end;
  111.       if (y1>=yc) or (y2>=yc) then
  112.         if (y1<=yc) or (y2<=yc) then
  113.           if not(y1=y2) then
  114.             begin
  115.               x:=(yc-y1)*mul2 div div2+x1;
  116.               if x<mnx then
  117.                 mnx:=x;
  118.               if x>mxx then
  119.                 mxx:=x;
  120.             end;
  121.       if (y2>=yc) or (y3>=yc) then
  122.         if (y2<=yc) or (y3<=yc) then
  123.           if not(y2=y3) then
  124.             begin
  125.               x:=(yc-y2)*mul3 div div3+x2;
  126.               if x<mnx then
  127.                 mnx:=x;
  128.               if x>mxx then
  129.                 mxx:=x;
  130.             end;
  131.       if (y3>=yc) or (y4>=yc) then
  132.         if (y3<=yc) or (y4<=yc) then
  133.           if not(y3=y4) then
  134.             begin
  135.               x:=(yc-y3)*mul4 div div4+x3;
  136.               if x<mnx then
  137.                 mnx:=x;
  138.               if x>mxx then
  139.                 mxx:=x;
  140.             end;
  141.       if mnx<0 then
  142.         mnx:=0;
  143.       if mxx>359 then
  144.         mxx:=359;
  145.       if mnx<=mxx then
  146.         hline (mnx,mxx,yc,color,page);
  147.     end;
  148.   end;
  149.  
  150. procedure LoadBloodyFont;
  151.  
  152.   var
  153.     fontfile:file;
  154.     chnum:byte;
  155.     crap:array[0..15] of byte;
  156.  
  157.  
  158.   Procedure LoadROMFont;
  159.  
  160.     var
  161.       f8x8ofs, f8x8seg : word;
  162.  
  163.     begin
  164.       asm
  165.         push bp
  166.         mov ah,11h
  167.         mov al,30h
  168.         mov bh,06h
  169.         int 10h
  170.         mov ax,bp
  171.         pop bp
  172.         mov f8x8ofs,ax
  173.         mov f8x8seg,es
  174.       end;
  175.       move(mem[f8x8seg:f8x8ofs],font,256*16)
  176.     end;
  177.  
  178.   begin
  179.     assign(fontfile, 'BLOODY.FNT');
  180.     {$I-}
  181.     reset(fontfile,1);
  182.     if ioresult<>0 then
  183.       loadROMfont
  184.     else
  185.       for chnum:=0 to 255 do
  186.         begin
  187.           blockread(fontfile,font[chnum,0],16);
  188.           blockread(fontfile,crap,16);
  189.         end;
  190.     {$I+}
  191.   end;
  192.  
  193. Procedure GrWrite (line : string; x, y : integer; color : byte);
  194.  
  195.   var
  196.     tx,ty:word;
  197.     i:byte;
  198.  
  199.   begin
  200.     for i:=1 to length(line) do
  201.       for ty:=0 to 15 do
  202.         for tx:=0 to 7 do
  203.           if font[ord(line[i]),ty] and ($80 shr tx)<>0 then
  204.             putpixel(x+tx+(i-1)*10, y+ty, color, page)
  205.   end;
  206.  
  207. procedure CenterText (Str : string; y : integer; color : byte);
  208.  
  209.   begin
  210.     GrWrite (Str, 320 div 2 - ((length (Str) * 10) div 2), y, Color)
  211.   end;
  212.  
  213. Procedure SBModPlay (md : string);
  214.  
  215.   var
  216.     stat : integer;
  217.  
  218.   begin
  219.     modinit;
  220.     modvolume (255,255,255,255);    { Full volume }
  221.     modsetup (stat, dev, 10000, 0, 4, md);
  222.   end;
  223.  
  224. procedure getdata;
  225.  
  226.   var
  227.     loop : integer;
  228.  
  229.   begin
  230. (*
  231.        +------ triangle number (1 through 17)
  232.        |   +--- point (1, 2, 3)
  233.        v   v
  234. *)
  235.     fillchar (t, sizeof (t), 0);
  236.  
  237.     t [1] [2].x := -10;
  238.     t [1] [2].y := 5;
  239.     t [1] [2].z := 0;
  240.     t [1] [3].x := -5;
  241.     t [1] [3].y := 10;
  242.     t [1] [3].z := 0;
  243.  
  244.     t [2] [2].x := -5;
  245.     t [2] [2].y := 10;
  246.     t [2] [2].z := 0;
  247.     t [2] [3].x := 5;
  248.     t [2] [3].y := 10;
  249.     t [2] [3].z := 0;
  250.  
  251.     t [3] [2].x := 5;
  252.     t [3] [2].y := 10;
  253.     t [3] [2].z := 0;
  254.     t [3] [3].x := 10;
  255.     t [3] [3].y := 5;
  256.     t [3] [3].z := 0;
  257.  
  258.     t [4] [2].x := 10;
  259.     t [4] [2].y := 5;
  260.     t [4] [2].z := 0;
  261.     t [4] [3].x := 10;
  262.     t [4] [3].y := -5;
  263.     t [4] [3].z := 0;
  264.  
  265.     t [5] [2].x := 10;
  266.     t [5] [2].y := -5;
  267.     t [5] [2].z := 0;
  268.     t [5] [3].x := 5;
  269.     t [5] [3].y := -10;
  270.     t [5] [3].z := 0;
  271.  
  272.     t [6] [2].x := 5;
  273.     t [6] [2].y := -10;
  274.     t [6] [2].z := 0;
  275.     t [6] [3].x := -5;
  276.     t [6] [3].y := -10;
  277.     t [6] [3].z := 0;
  278.  
  279.     t [7] [2].x := -5;
  280.     t [7] [2].y := -10;
  281.     t [7] [2].z := 0;
  282.     t [7] [3].x := -10;
  283.     t [7] [3].y := -5;
  284.     t [7] [3].z := 0;
  285.  
  286.     t [8] [2].x := -10;
  287.     t [8] [2].y := -5;
  288.     t [8] [2].z := 0;
  289.     t [8] [3].x := -10;
  290.     t [8] [3].y := 5;
  291.     t [8] [3].z := 0;
  292.  
  293.     t [9] [1].x := -5;
  294.     t [9] [1].y := 10;
  295.     t [9] [1].z := 0;
  296.     t [9] [2].x := -5;
  297.     t [9] [2].y := 18;
  298.     t [9] [2].z := 0;
  299.     t [9] [3].x := -4;
  300.     t [9] [3].y := 10;
  301.     t [9] [3].z := 0;
  302.  
  303.     t [10] [1].x := -5;
  304.     t [10] [1].y := 18;
  305.     t [10] [1].z := 0;
  306.     t [10] [2].x := -4;
  307.     t [10] [2].y := 10;
  308.     t [10] [2].z := 0;
  309.     t [10] [3].x := -3;
  310.     t [10] [3].y := 18;
  311.     t [10] [3].z := 0;
  312.  
  313.     t [11] [1].x := -3;
  314.     t [11] [1].y := 18;
  315.     t [11] [1].z := 0;
  316.     t [11] [2].x := -4;
  317.     t [11] [2].y := 10;
  318.     t [11] [2].z := 0;
  319.     t [11] [3].x := -3;
  320.     t [11] [3].y := 10;
  321.     t [11] [3].z := 0;
  322.  
  323.     t [12] [1].x := -1;
  324.     t [12] [1].y := 10;
  325.     t [12] [1].z := 0;
  326.     t [12] [2].x := -1;
  327.     t [12] [2].y := 18;
  328.     t [12] [2].z := 0;
  329.     t [12] [3].x := 0;
  330.     t [12] [3].y := 10;
  331.     t [12] [3].z := 0;
  332.  
  333.     t [13] [1].x := -1;
  334.     t [13] [1].y := 18;
  335.     t [13] [1].z := 0;
  336.     t [13] [2].x := 0;
  337.     t [13] [2].y := 10;
  338.     t [13] [2].z := 0;
  339.     t [13] [3].x := 1;
  340.     t [13] [3].y := 18;
  341.     t [13] [3].z := 0;
  342.  
  343.     t [14] [1].x := 1;
  344.     t [14] [1].y := 18;
  345.     t [14] [1].z := 0;
  346.     t [14] [2].x := 0;
  347.     t [14] [2].y := 10;
  348.     t [14] [2].z := 0;
  349.     t [14] [3].x := 1;
  350.     t [14] [3].y := 10;
  351.     t [14] [3].z := 0;
  352.  
  353.     t [15] [1].x := 3;
  354.     t [15] [1].y := 10;
  355.     t [15] [1].z := 0;
  356.     t [15] [2].x := 3;
  357.     t [15] [2].y := 18;
  358.     t [15] [2].z := 0;
  359.     t [15] [3].x := 4;
  360.     t [15] [3].y := 10;
  361.     t [15] [3].z := 0;
  362.  
  363.     t [16] [1].x := 3;
  364.     t [16] [1].y := 18;
  365.     t [16] [1].z := 0;
  366.     t [16] [2].x := 4;
  367.     t [16] [2].y := 10;
  368.     t [16] [2].z := 0;
  369.     t [16] [3].x := 5;
  370.     t [16] [3].y := 18;
  371.     t [16] [3].z := 0;
  372.  
  373.     t [17] [1].x := 5;
  374.     t [17] [1].y := 18;
  375.     t [17] [1].z := 0;
  376.     t [17] [2].x := 4;
  377.     t [17] [2].y := 10;
  378.     t [17] [2].z := 0;
  379.     t [17] [3].x := 5;
  380.     t [17] [3].y := 10;
  381.     t [17] [3].z := 0;
  382.  
  383.     fillchar (velocity, sizeof (velocity), 0);
  384.  
  385.     for loop := 1 to 17 do
  386.       begin
  387.         velocity [loop].x := 160;
  388.         velocity [loop].y := 100
  389.       end;
  390.  
  391.     velocity [1].dx := -2;
  392.     velocity [1].dy := 1;
  393.  
  394.     velocity [1].dt1 := 6;
  395.     velocity [1].dt2 := 6;
  396.  
  397.     velocity [2].dy := 2;
  398.     velocity [2].dt2 := 6;
  399.  
  400.     velocity [3].dx := 2;
  401.     velocity [3].dy := 1;
  402.  
  403.     velocity [3].dt1 := 6;
  404.     velocity [3].dt2 := -6;
  405.  
  406.     velocity [4].dx := 3;
  407.  
  408.     velocity [4].dt1 := 8;
  409.  
  410.     velocity [5].dx := 2;
  411.     velocity [5].dy := -1;
  412.  
  413.     velocity [5].dt1 := -6;
  414.     velocity [5].dt2 := -6;
  415.  
  416.     velocity [6].dy := -2;
  417.     velocity [6].dt2 := -6;
  418.  
  419.     velocity [7].dx := -2;
  420.     velocity [7].dy := -1;
  421.  
  422.     velocity [7].dt1 := -6;
  423.     velocity [7].dt2 := 6;
  424.  
  425.     velocity [8].dx := -3;
  426.  
  427.     velocity [8].dt1 := -8;
  428.  
  429.     { =-=-=-=-=-=-= }
  430.     {     Teeth     }
  431.     { =-=-=-=-=-=-= }
  432.  
  433.     velocity [9].dx := -2;
  434.     velocity [9].dy := 1;
  435.     velocity [9].dt1 := 3;
  436.     velocity [9].dt2 := 3;
  437.     velocity [10].dx := -2;
  438.     velocity [10].dy := 1;
  439.     velocity [10].dt1 := 3;
  440.     velocity [10].dt2 := 3;
  441.     velocity [11].dx := -2;
  442.     velocity [11].dy := 1;
  443.     velocity [11].dt1 := 3;
  444.     velocity [11].dt2 := 3;
  445.  
  446.     velocity [12].dy := 2;
  447.     velocity [12].dt2 := 4;
  448.     velocity [13].dy := 2;
  449.     velocity [13].dt2 := 4;
  450.     velocity [14].dy := 2;
  451.     velocity [14].dt2 := 4;
  452.  
  453.     velocity [15].dx := 2;
  454.     velocity [15].dy := 1;
  455.     velocity [15].dt1 := -3;
  456.     velocity [15].dt2 := -3;
  457.     velocity [16].dx := 2;
  458.     velocity [16].dy := 1;
  459.     velocity [16].dt1 := -3;
  460.     velocity [16].dt2 := -3;
  461.     velocity [17].dx := 2;
  462.     velocity [17].dy := 1;
  463.     velocity [17].dt1 := -3;
  464.     velocity [17].dt2 := -3;
  465.  
  466.     for loop := 1 to 17 do
  467.       begin
  468.         velocity [loop].dx := velocity [loop].dx * 8;
  469.         velocity [loop].dy := velocity [loop].dy * 8;
  470.       end;
  471.  
  472.   end;
  473.  
  474. function rad (a : real) : real;
  475.  
  476.   begin
  477.     rad := a * pi / 180
  478.   end;
  479.  
  480. procedure rotateall (lrtheta, udtheta, circtheta : real;
  481.   xshift, yshift: integer);
  482.  
  483.   var
  484.     xa, ya, ca, e, f : real;
  485.     coslrtheta, sinlrtheta, cosudtheta, sinudtheta, coscirctheta,
  486.     sincirctheta : real;
  487.     loop, loop2 : integer;
  488.  
  489.   begin
  490.     coslrtheta := cos (lrtheta);
  491.     sinlrtheta := sin (lrtheta);
  492.     cosudtheta := cos (udtheta);
  493.     sinudtheta := sin (udtheta);
  494.     coscirctheta := cos (circtheta);
  495.     sincirctheta := sin (circtheta);
  496.     for loop := 1 to 17 do
  497.       for loop2 := 1 to 3 do
  498.         begin
  499.           xa := (coslrtheta * t [loop][loop2].x) -
  500.             (sinlrtheta * t [loop][loop2].z);
  501.           ca := (sinlrtheta * t [loop][loop2].x) +
  502.             (coslrtheta * t [loop][loop2].z);
  503.           e := (coscirctheta * xa) + (sincirctheta * t [loop][loop2].y);
  504.           ya := (coscirctheta * t [loop][loop2].y) - (sincirctheta * xa);
  505.           t2 [loop][loop2].z := round ((cosudtheta * ca) - (sinudtheta * ya));
  506.           f := (sinudtheta * ca) + (cosudtheta * ya);
  507.           t2 [loop][loop2].x := round (e * 3 + xshift);
  508.           t2 [loop][loop2].y := round (f * 3 + yshift);
  509.         end;
  510.     xa := (coslrtheta * -4);
  511.     ca := (sinlrtheta * -4);
  512.     e := (coscirctheta * xa) + (sincirctheta * 3);
  513.     ya := (coscirctheta * 3) - (sincirctheta * xa);
  514.     f := (sinudtheta * ca) + (cosudtheta * ya);
  515.     eye1x := round (e * 3 + xshift);
  516.     eye1y := round (f * 3 + yshift);
  517.     xa := (coslrtheta * 4);
  518.     ca := (sinlrtheta * 4);
  519.     e := (coscirctheta * xa) + (sincirctheta * 3);
  520.     ya := (coscirctheta * 3) - (sincirctheta * xa);
  521.     f := (sinudtheta * ca) + (cosudtheta * ya);
  522.     eye2x := round (e * 3 + xshift);
  523.     eye2y := round (f * 3 + yshift);
  524.  
  525.     xa := (coslrtheta * -1);
  526.     ca := (sinlrtheta * -1);
  527.     e := (coscirctheta * xa) + (sincirctheta * 7);
  528.     ya := (coscirctheta * 7) - (sincirctheta * xa);
  529.     f := (sinudtheta * ca) + (cosudtheta * ya);
  530.     nose1x := round (e * 3 + xshift);
  531.     nose1y := round (f * 3 + yshift);
  532.  
  533.     xa := (coslrtheta * -1);
  534.     ca := (sinlrtheta * -1);
  535.     e := (coscirctheta * xa) + (sincirctheta * 9);
  536.     ya := (coscirctheta * 9) - (sincirctheta * xa);
  537.     f := (sinudtheta * ca) + (cosudtheta * ya);
  538.     nose2x := round (e * 3 + xshift);
  539.     nose2y := round (f * 3 + yshift);
  540.  
  541.     xa := (coslrtheta * -2);
  542.     ca := (sinlrtheta * -2);
  543.     e := (coscirctheta * xa) + (sincirctheta * 9);
  544.     ya := (coscirctheta * 9) - (sincirctheta * xa);
  545.     f := (sinudtheta * ca) + (cosudtheta * ya);
  546.     nose3x := round (e * 3 + xshift);
  547.     nose3y := round (f * 3 + yshift);
  548.  
  549.     xa := (coslrtheta * 1);
  550.     ca := (sinlrtheta * 1);
  551.     e := (coscirctheta * xa) + (sincirctheta * 7);
  552.     ya := (coscirctheta * 7) - (sincirctheta * xa);
  553.     f := (sinudtheta * ca) + (cosudtheta * ya);
  554.     nose4x := round (e * 3 + xshift);
  555.     nose4y := round (f * 3 + yshift);
  556.  
  557.     xa := (coslrtheta * 1);
  558.     ca := (sinlrtheta * 1);
  559.     e := (coscirctheta * xa) + (sincirctheta * 9);
  560.     ya := (coscirctheta * 9) - (sincirctheta * xa);
  561.     f := (sinudtheta * ca) + (cosudtheta * ya);
  562.     nose5x := round (e * 3 + xshift);
  563.     nose5y := round (f * 3 + yshift);
  564.  
  565.     xa := (coslrtheta * 2);
  566.     ca := (sinlrtheta * 2);
  567.     e := (coscirctheta * xa) + (sincirctheta * 9);
  568.     ya := (coscirctheta * 9) - (sincirctheta * xa);
  569.     f := (sinudtheta * ca) + (cosudtheta * ya);
  570.     nose6x := round (e * 3 + xshift);
  571.     nose6y := round (f * 3 + yshift);
  572.  
  573.   end;
  574.  
  575. procedure FadeInSkull;
  576.  
  577.   var
  578.     tcount, red, white, iteration : integer;
  579.     red_up : boolean;
  580.  
  581.   begin
  582.     rgb (1, 0, 0, 0);
  583.     rgb (15, 0, 0, 0);
  584.     rotateall (0, rad (5), rad (5), 160, 85);
  585.     for tcount := 1 to 17 do
  586.       begin
  587.         DrawQuad (t2 [tcount] [1].x, t2 [tcount] [1].y,
  588.           t2 [tcount] [2].x, t2 [tcount] [2].y,
  589.           t2 [tcount] [3].x, t2 [tcount] [3].y,
  590.           t2 [tcount] [3].x, t2 [tcount] [3].y, 15)
  591.       end;
  592.  
  593.     DrawQuad (nose1x, nose1y, nose2x, nose2y, nose3x, nose3y, nose1x, nose1y, 0);
  594.     DrawQuad (nose4x, nose4y, nose5x, nose5y, nose6x, nose6y, nose4x, nose4y, 0);
  595.  
  596.  
  597.     fillcircle (eye1x, eye1y, 5, 0);
  598.     fillcircle (eye1x, eye1y, 3, 1);
  599.     fillcircle (eye1x, eye1y, 2, 2);
  600.     fillcircle (eye2x, eye2y, 5, 0);
  601.     fillcircle (eye2x, eye2y, 3, 1);
  602.     fillcircle (eye2x, eye2y, 2, 2);
  603.  
  604.     red := 10;
  605.     white := 0;
  606.     red_up := true;
  607.     repeat
  608.       inc (iteration);
  609.       if red_up then inc (red)
  610.         else dec (red);
  611.       if red >= 63 then red_up := false;
  612.       if red <= 10 then red_up := true;
  613.       if iteration > 1000 then
  614.         if (white < 63) and (iteration mod 20 = 0) then
  615.           inc (white);
  616.       rgb (1, red, 0, 0);
  617.       rgb (2, red - 10, 0, 0);
  618.       rgb (15, white, white, white)
  619.     until keypressed or (iteration >= 2200);
  620.   end;
  621.  
  622. procedure RotateSkull;
  623.  
  624.   var
  625.     tcount, loop, loop2, loop3, x, y, dx, dy, red, iterations : integer;
  626.     red_up : boolean;
  627.  
  628.   begin
  629.     loop := 0;
  630.     loop2 := 5;
  631.     loop3 := 5;
  632.     x := 154;
  633.     y := 76;
  634.     dx := 6;
  635.     dy := 4;
  636.     red := 0;
  637.     red_up := true;
  638.     iterations := 0;
  639.     while not keypressed and (iterations < 85) do
  640.       begin
  641.     inc (iterations);
  642.     inc (x, dx);
  643.     inc (y, dy);
  644.     if x > 310 then dx := -6
  645.       else
  646.     if x < 50 then dx := 6;
  647.     if y > 150 then dy := -4
  648.       else
  649.     if y < 50 then dy := 4;
  650.  
  651.     if dx > 0 then dec (loop, 10)
  652.       else inc (loop, 10);
  653.  
  654.     if red_up then inc (red, 10)
  655.       else dec (red, 10);
  656.     if red + 10 > 63 then red_up := false;
  657.     if red - 10 < 0 then red_up := true;
  658.  
  659.     rotateall (rad (loop*2), rad (loop2*2), rad (loop3*2), x, y);
  660.     for tcount := 1 to 17 do
  661.       begin
  662.         DrawQuad (t2 [tcount] [1].x, t2 [tcount] [1].y,
  663.           t2 [tcount] [2].x, t2 [tcount] [2].y,
  664.           t2 [tcount] [3].x, t2 [tcount] [3].y,
  665.           t2 [tcount] [3].x, t2 [tcount] [3].y, 15)
  666.       end;
  667.  
  668.     DrawQuad (nose1x, nose1y, nose2x, nose2y, nose3x, nose3y, nose1x, nose1y, 0);
  669.     DrawQuad (nose4x, nose4y, nose5x, nose5y, nose6x, nose6y, nose4x, nose4y, 0);
  670.  
  671.     rgb (1, red, 0, 0);
  672.     fillcircle (eye1x, eye1y, 5, 0);
  673.     fillcircle (eye1x, eye1y, 3, 1);
  674.     fillcircle (eye2x, eye2y, 5, 0);
  675.     fillcircle (eye2x, eye2y, 3, 1);
  676.  
  677.       screen (page);
  678.       inc (page);
  679.       if page > 2 then page := 0;
  680.       clearscreen (page);
  681.     end;
  682.   end;
  683.  
  684. procedure Explosion;
  685.  
  686.   var
  687.     tcount, loop : integer;
  688.  
  689.   procedure rotate (n : integer; lrtheta, udtheta, circtheta : real;
  690.     xshift, yshift: integer);
  691.  
  692.     var
  693.       xa, ya, ca, e, f : real;
  694.       coslrtheta, sinlrtheta, cosudtheta, sinudtheta, coscirctheta,
  695.       sincirctheta : real;
  696.       loop2 : integer;
  697.  
  698.     begin
  699.       coslrtheta := cos (lrtheta);
  700.       sinlrtheta := sin (lrtheta);
  701.       cosudtheta := cos (udtheta);
  702.       sinudtheta := sin (udtheta);
  703.       coscirctheta := cos (circtheta);
  704.       sincirctheta := sin (circtheta);
  705.       for loop2 := 1 to 3 do
  706.         begin
  707.           xa := (coslrtheta * t [n][loop2].x) -
  708.             (sinlrtheta * t [n][loop2].z);
  709.           ca := (sinlrtheta * t [n][loop2].x) +
  710.             (coslrtheta * t [n][loop2].z);
  711.           e := (coscirctheta * xa) + (sincirctheta * t [n][loop2].y);
  712.           ya := (coscirctheta * t [n][loop2].y) - (sincirctheta * xa);
  713.           t2 [n][loop2].z := round ((cosudtheta * ca) - (sinudtheta * ya));
  714.           f := (sinudtheta * ca) + (cosudtheta * ya);
  715.           t2 [n][loop2].x := round (e * 3 + xshift);
  716.           t2 [n][loop2].y := round (f * 3 + yshift);
  717.         end
  718.     end;
  719.  
  720.   begin
  721.     loop := 0;
  722.     ModStop;
  723.     SBModPlay ('1.MOD');
  724.     while not keypressed and (loop < 300) do
  725.       begin
  726.  
  727.     for tcount := 1 to 17 do
  728.       if (velocity [tcount].x > 0) and (velocity [tcount].x < 320)
  729.         and (velocity [tcount].y > 0) and (velocity [tcount].y < 200) then
  730.       begin
  731.         rotate (tcount, rad (velocity [tcount].theta1),
  732.           rad (velocity [tcount].theta2),
  733.           rad (velocity [tcount].theta3),
  734.           velocity [tcount].x, velocity [tcount].y);
  735.         inc (velocity [tcount].x, velocity [tcount].dx);
  736.         inc (velocity [tcount].y, velocity [tcount].dy);
  737.         inc (velocity [tcount].theta1, velocity [tcount].dt1);
  738.         inc (velocity [tcount].theta2, velocity [tcount].dt2);
  739.         inc (velocity [tcount].theta3, velocity [tcount].dt3);
  740.         DrawQuad (t2 [tcount] [1].x, t2 [tcount] [1].y,
  741.           t2 [tcount] [2].x, t2 [tcount] [2].y,
  742.           t2 [tcount] [3].x, t2 [tcount] [3].y,
  743.           t2 [tcount] [3].x, t2 [tcount] [3].y, 15)
  744.       end;
  745.       screen (page);
  746.       inc (page);
  747.       if page > 2 then page := 0;
  748.       clearscreen (page);
  749.       inc (loop, 10);
  750.       if loop = 360 then loop := 0;
  751.     end;
  752.   end;
  753.  
  754. procedure MorbidText;
  755.  
  756.   procedure DripColor (x1, y1, x2, y2 : integer; c1, c2 : byte);
  757.  
  758.     var
  759.       x, y : integer;
  760.  
  761.     procedure CheckColor (x, y : integer);
  762.  
  763.       begin
  764.         if getpixel (x, y, page) = 0 then putpixel (x, y, c2, page)
  765.       end;
  766.  
  767.     begin
  768.       for y := y1 to y2 do
  769.         for x := x1 to x2 do
  770.           begin
  771.             if getpixel (x, y, page) = c1 then
  772.               begin
  773.                 CheckColor (x - 1, y);
  774.                 CheckColor (x - 1, y - 1);
  775.                 CheckColor (x, y - 1);
  776.                 CheckColor (x + 1, y);
  777.                 CheckColor (x + 1, y + 1);
  778.                 CheckColor (x, y + 1);
  779.                 CheckColor (x - 1, y + 1);
  780.                 CheckColor (x + 1, y - 1);
  781.               end
  782.           end
  783.     end;
  784.  
  785.   procedure FadeIn;
  786.  
  787.     var
  788.       loop : integer;
  789.  
  790.     begin
  791.       for loop := 0 to 30 do
  792.         begin
  793.           rgb (1, loop, 0, 0);
  794.           rgb (2, loop * 2, 0, 0);
  795.           delay (10);
  796.         end;
  797.     end;
  798.  
  799.   procedure FadeOut;
  800.  
  801.     var
  802.       loop : integer;
  803.  
  804.     begin
  805.       for loop := 30 downto 0 do
  806.         begin
  807.           rgb (1, loop, 0, 0);
  808.           rgb (2, loop * 2, 0, 0);
  809.           delay (10);
  810.         end;
  811.     end;
  812.  
  813.   begin
  814.     if keypressed then Exit;
  815.     page := 0;
  816.     ClearScreen (0);
  817.     Screen (0);
  818.     ClearScreen (0);
  819.     delay (1000);
  820.     ClearScreen (1);
  821.     page := 1;
  822.     CenterText ('Morbid Demo', 85, 2);
  823.     DripColor (100, 85, 220, 100, 2, 1);
  824.     Screen (1);
  825.     FadeIn;
  826.     delay (1000);
  827.     FadeOut;
  828.     Screen (0);
  829.     delay (1000);
  830.     ClearScreen (1);
  831.     page := 1;
  832.     CenterText ('Coming Soon', 85, 2);
  833.     DripColor (100, 85, 220, 100, 2, 1);
  834.     Screen (1);
  835.     FadeIn;
  836.     delay (1000);
  837.     FadeOut;
  838.     Screen (0);
  839.     delay (1000);
  840.   end;
  841.  
  842. begin
  843.   CheckBreak := false;  { or else someone who presses Ctrl-C will lock-up}
  844.   getdata;              { their computer }
  845.   page := 0;
  846.   ClrScr;
  847.   ModInit;
  848.   ModDevice (dev);
  849.   setmode13x4;
  850.   LoadBloodyFont;
  851.   SBModPlay ('0.MOD');
  852.   delay (2000);
  853.   setmode13x4;
  854.   FadeInSkull;
  855.   RotateSkull;
  856.   Explosion;
  857.   ModStop;
  858.   MorbidText;
  859.   textmode (lastmode)
  860. end.